#!/usr/bin/perl
#file: autolog.pl 
#created: 5-13-2011
#author: Tim Bergsma, copyright (C) 2011 Metrum Research Group, LLC.

#This program is free software; you can redistribute it and/or
#modify it under the terms of the GNU General Public License
#as published by the Free Software Foundation; either version 2
#of the License, or (at your option) any later version.

#This program is distributed in the hope that it will be useful,
#but WITHOUT ANY WARRANTY; without even the implied warranty of
#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#GNU General Public License for more details.

#You should have received a copy of the GNU General Public License
#along with this program; if not, write to the Free Software
#Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.

#purpose: autolog.pl is a logging processor of xml files having the form:
#<config><alias id='x'>text</alias><do on='y' in='z'>cmd text</do><to on='y'>file</to></config>

#modified: 9-21-2012 Tim Bergsma.  Adding support for aliases $0 and $_0.

use strict;
use warnings;
use XML::XPath;
use Cwd;

unless (@ARGV){
	die <<EOF;
	
	usage: perl autolog.pl config.xml mode [args]

	see http://nmqual.googlecode.com

EOF
}

# Tasks:
#1.  Intercept the config argument. read the first config node of the config file.
#2.  If there are remaining arguments, and if the next one is an 'on' attribute in the config file, intercept that as mode specifier.
#3.  Subset the config as non-modal top-level elements plus mode-specific elements (if any).
#4.  Read all aliases in config, substituting cumulatively.
#5.  Substitute all aliases into remaining instructions and directories.
#6.  Substitute any remaining arguments into instructions: all args ($_) or counted args ($_1, $_2, etc.).  
#    Additionally (9-21-2012), Let $_0 be the path to the config file, and let $0 be the path to this script (copied from Perl, per POSIX).
#7.  Execute each instruction (in a particular directory if specified), capturing output and dying as necessary.
#8.  Build a log inclusive of the original config. <autolog on='mode'><config/><job><do/><so/></job></autolog>
#9.  If "to" is specified and exists, read as xml and use that as context.  Else create <log> context.
#10. Append log to context.
#11. Write context to "to" specified in config, if any, or to standard output.


#parse config file
my $configfile = shift @ARGV;
my $configXPath = XML::XPath->new(filename => $configfile) or die "$!\n";
my $configRootNode = $configXPath->findnodes('//config')->[0]; #set root node to first-avail configuration node
my $config = XML::XPath->new(context => $configRootNode); #simplifies the search syntax.

#detect mode argument
my $mode = 0;
my $file = 0;
if(@ARGV){
	my $nxt = shift @ARGV;
	my @on = $config->findnodes('*/@on')->get_nodelist;
	$_ = $_->string_value foreach @on;
	if (!!grep { $_ eq $nxt } @on){#test whether next arg is an 'on' attribute in config file
		$mode = $nxt
	}else{
		unshift @ARGV, $nxt
	}
}
#limit config to mode as necessary
my $activeNodes = $config->findnodes("*[not(\@on)]");
if($mode){$activeNodes = $config->findnodes("*[not(\@on) or \@on='$mode']");}
foreach my $arg (@ARGV){$arg = cq($arg);} #conditional quotes (double quotes are supplied if arg contains space)
my $args = join(' ',@ARGV);
	
#process nodes with respect to aliases
#for each node, substitute all existing aliases globally, and post new alias if node is an alias
my %aliases = ();
my @do = ();
my @so = ();
my @in = ();
my @activeNodes = $activeNodes->get_nodelist;
#will there be a file?
foreach(@activeNodes){
	my $name = $_->getLocalName;
	if($name eq 'to'){
		$file = 1;
	}
}
foreach (@activeNodes){
	my $cwd = getcwd;
	#scavenge element data
	my $name = $_->getLocalName;
	my $text = $_->string_value;
	my $id    = $_->getAttribute('id');
	my $dir   = $_->getAttribute('in');
	my $as    = $_->getAttribute('as');
	#perform registered substitutions
	if ($text) {$text=~s/$_/$aliases{$_}/g foreach keys %aliases;}
	if ($dir)  {$dir =~s/$_/$aliases{$_}/g foreach keys %aliases;}
	#perform argument substitutions for pattern $_num .
	foreach my $num (1..@ARGV){
		my $pattern ="\$_$num";
		$pattern = quotemeta($pattern);
		my $replacement = $ARGV[$num - 1];
		$text=~s/$pattern/$replacement/g if $text;
		$dir =~s/$pattern/$replacement/g if $dir;
	}
	#perform agrument substitution (all args) for pattern $_ .
	$text=~s/\$\_(\D|$)/$args$1/ if $text;
	$dir =~s/\$\_(\D|$)/$args$1/ if $dir;
	#perform agrument substitution (config file) for pattern $_0.
	$text=~s/\$\_0(\D|$)/$configfile$1/ if $text;
	$dir =~s/\$\_0(\D|$)/$configfile$1/ if $dir;
	#perform agrument substitution (script file) for pattern $0.
	$text=~s/\$0(\D|$)/$0$1/ if $text;
	$dir =~s/\$0(\D|$)/$0$1/ if $dir;
	#evaluate and harvest job output
	if ($text and $name eq 'do'){
		if ($file){
			if ($dir) {print "$dir"};
			print ">$text\n";
		}
		if ($dir) {chdir $dir or die "can't change dir to $dir\n$!\n";}
		my $result = `$text`;
		#principal fail condition of this script:
		die "$text\n$!\n" unless defined $result;
		$text = XML::XPath::Node::Text->new($text);
		if($as and $as=~/^xml$/i){
			#ASCII encoding not recognized in expat, Perl.
			$result=~s/encoding="ASCII"/encoding="US-ASCII"/;
			#We choose not to validate against DTD's.
			$result=~s/<!DOCTYPE[^>]+>//i;
			$result = XML::XPath->new(xml => $result)->findnodes('/*')->[0] or die "$!\n";
		}else{
			$result = XML::XPath::Node::Text->new($result) or die "$!\n";
		}
		push @do, $text or die "$!\n";
		push @so, $result or die "$!\n";
		push @in, $dir or die "$!\n";
		if ($dir) {chdir $cwd or die "can't restore dir $cwd\n$!\n";}
	}
	#conditionally register new substitution
	if ($id and $name eq 'alias'){$aliases{$id}=$text};
	#capture file name
	if ($name eq 'to') {$file = $text};
}
#create log
my $root = XML::XPath::Node::Element->new('logged');
my $xlog = XML::XPath->new(context => $root);
if ($mode) {attach($xlog, '@on', $mode);}
$root->appendChild($configRootNode);
die "array length mismatch\n" unless scalar(@do)==scalar(@so);
die "array length mismatch\n" unless scalar(@do)==scalar(@in);
foreach my $num (1..@do){
	my $job = XML::XPath::Node::Element->new('job');
	my $do  = XML::XPath::Node::Element->new('do');
	my $so  = XML::XPath::Node::Element->new('so');
	my $dir = $in[$num -1];
	my $attr = XML::XPath::Node::Attribute->new('in',$dir);
	$do->appendAttribute($attr) if $dir;
	$do->appendChild($do[$num - 1]);
	$so->appendChild($so[$num - 1]);
	$job->appendChild($do);
	$job->appendChild($so);
	$root->appendChild($job);
}

#create generic context.
my $generic = XML::XPath::Node::Element->new('log');
if ($file and (-f $file)){
	$generic = XML::XPath->new(filename => $file)->findnodes('/*')->[0] or die "$!\n";
}
$generic->appendChild($root);

#generate output
my $result = $generic->toString;
$result = pretty($result);
if($file){
	open (OUTFILE, ">$file") or die "can't open $file for writing\n$!\n";
	print OUTFILE $result;
	close OUTFILE;
}else{
	print $result;
}

############ subroutines ############

#easy syntax for XPath tree building
sub attach{
	my $xlog = shift;
	my $path = shift;
	my $nodeText = shift;
	$xlog->createNode($path);
	$xlog->setNodeText($path, $nodeText) if defined($nodeText);
}
#conditional quote: if argument contains spaces
sub cq{
	my $arg = shift;
	$arg = "\"$arg\"" if grep /\s/, $arg;
	return $arg;
}
#pretty-prints xml
sub pretty{
	$_ = shift;                       # the file, all as one string
	s">[\n\s]*<"><"g;                 # remove inter-element prettiness
	s"<!--[\n\s]*"<!--"g;             # remove begin-comment prettiness
	s"[\n\s]*-->"-->"g;               # remove end-comment prettiness
	s"(<[^/])"\n$1"g;                 # newline before every begin-element
	s"^\n"";                          # eliminate initial newline
	s"></">\n</"g;                    # newline before successor end-element
	s">-->">\n-->"g;                  # newline before successor end-comment
	s"([^>])\n</"$1</"g;              # drop noninformative newline after text
	s"(<[^/!]+>)\n</"$1</"g;          # fuse empty element
	s"(<[^/! ]+.*)></[^>]+>"$1 />"g;  # collapse empty element
	s"\s/>"/>"g;                      # trim empty element
	my @lines = split('\n',$_);
	my $depth = -1;
	foreach my $line (@lines){
		$depth+=1 if $line=~'^<[^/]';           # increase depth for begin-element
		$line = ( ' ' x $depth ) . $line;       # indent to depth
		$depth-=1 if $line=~'(/>)|(</)|(-->)';  # decrease depth for end-element
	}
	$_ = join "\n", @lines;
	$_ = $_ . "\n";
	$_
}

